home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / gls / generics.scm < prev    next >
Encoding:
Text File  |  1995-08-17  |  6.1 KB  |  192 lines
  1. ;; A mechanism for defining an ordering of procedures.
  2. ;; This is used to order descriminator predicates
  3. ;; used in the declarations of generic functions.
  4. ;;
  5. (define (is-a a b)
  6.   (if (not (eq? a b))
  7.       (if (is-a? b a)
  8.       (error 'circular-subclassing)
  9.       (set-procedure-property! a
  10.                    'is-a
  11.                    (cons b (or (procedure-property a 'is-a)
  12.                            '()))))))
  13. (define (is-a? a b)
  14.   (cond
  15.    ((eq? a b) #t)
  16.    ((eq? b #t) #t)
  17.    ((member b (procedure-property a 'is-a)) #t)
  18.    ((or-map (lambda (p) (is-a? p b)) (procedure-property a 'is-a)) #t) 
  19.    (#t #f)))
  20.  
  21.  
  22. (define (make-lock mechanism locked) (cons mechanism locked))
  23. (define (open-lock? lock key locked) (and lock
  24.                       (eq? locked (cdr lock))
  25.                       ((car lock) lock key)))
  26.  
  27.  
  28. ;; A method is represented by a list: (<signature> <procedure>)
  29. ;; These are orded by comparing signatures.  Normally, a signature
  30. ;; is a list of descriminator procedures, ordered lexically by IS-A?.
  31. ;;
  32. (define (default-method-ordering a b)
  33.   (set! a (car a))
  34.   (set! b (car b))
  35.   (let loop ((a a)
  36.          (b b))
  37.     (cond
  38.      ((and (null? a) (null? b)) #f)
  39.      ((null? a) #t)
  40.      ((null? b) #f)
  41.      ((not (pair? a))  (cond ((not (pair? b)) (is-a? a b))
  42.                  (else #f)))
  43.      ((not (pair? b)) #t)
  44.      ((eq? (car a) (car b)) (loop (cdr a) (cdr b)))
  45.      ((is-a? (car a) (car b)) #t)
  46.      ((is-a? (car b) (car a)) #f)
  47.      (else (loop (cdr a) (cdr b))))))
  48.  
  49.  
  50. ;; The default action of a generic function:
  51. ;;
  52. (define (default-method . args)
  53.   (apply error 'not-implemented args))
  54.  
  55.  
  56. ;; If method-case (a list (<sig> <proc>)) applies
  57. ;; to args, return method-case, else return #f.
  58. ;;
  59. (define (method-case-applies method-case args)
  60.   (let loop ((preds (car method-case))
  61.          (args args))
  62.     (cond
  63.      ((and (pair? preds)
  64.        (pair? args)
  65.        (or (eq? #t (car preds))
  66.            ((car preds) (car args))))
  67.       (loop (cdr preds) (cdr args)))
  68.      ((and (null? preds)
  69.        (null? args))
  70.       method-case)
  71.      ((and (not (null? preds))
  72.        (procedure? preds)
  73.        (preds args))
  74.       method-case)
  75.      ((eq? #t preds) method-case)
  76.      (else #f))))
  77.  
  78. (begin
  79.   (define generic-things
  80.     (let* ((alist-set! (alist-associator eq?))
  81.        (secret (cons 'generic 'secret))
  82.        (secret? (lambda (x) (eq? secret x)))
  83.        (test-lock (lambda (lock key) (secret? key))))
  84.  
  85.       (letrec ((tag-basic-generic (lambda (proc mop)
  86.                     (set-procedure-property! proc
  87.                                  tag-basic-generic
  88.                                (make-lock test-lock proc))
  89.                     (set-procedure-property! proc test-lock mop)
  90.                     proc))
  91.            (basic-generic? (lambda (obj)
  92.                  (and (procedure? obj)
  93.                       (open-lock? (procedure-property obj tag-basic-generic)
  94.                           secret
  95.                           obj))))
  96.            (basic-mop (lambda (generic) (and (basic-generic? generic)
  97.                          (procedure-property generic test-lock))))
  98.            (basic-make-generic (lambda args
  99.                      (let ((mop-options (if args (car args) '()))
  100.                        (args (and args (cdr args))))
  101.                        (letrec ((state #f)
  102.                         (mop (or (kw-arg-ref mop-options :mop-method)
  103.                              (lambda (protocol generic . args)
  104.                                (case protocol
  105.                                  ((init)
  106.                                   (apply (or (kw-arg-ref mop-options :init)
  107.                                      (lambda (state mop)
  108.                                        (mop 'set-state! #f (cons '() '()))
  109.                                        (let ((d (mop 'dispatcher #f)))
  110.                                          (tag-basic-generic d mop)
  111.                                          d)))
  112.                                      state generic args))
  113.  
  114.                                  ((add-method!)
  115.                                   (apply (or (kw-arg-ref mop-options :add-method!)
  116.                                      (lambda (state generic sig method)
  117.                                        (set-car! state
  118.                                              (alist-set! (car state)
  119.                                                  sig
  120.                                                  (list method)))
  121.                                        (set-cdr! state #f)))
  122.                                      state generic args))
  123.                                  ((method-ordering)
  124.                                   (apply (or (kw-arg-ref mop-options :method-ordering)
  125.                                      (lambda (g)
  126.                                        default-method-ordering))
  127.                                      generic args))
  128.                                  ((register-methods)
  129.                                   (apply (or (kw-arg-ref mop-options :register-methods)
  130.                                      (lambda (state generic)
  131.                                        (set-cdr! state
  132.                                              (sort (car state)
  133.                                                (mop 'method-ordering
  134.                                                 generic)))))
  135.                                      state generic args))
  136.                                  ((dispatcher)
  137.                                   (apply (or (kw-arg-ref mop-options :dispatcher)
  138.                                      (lambda (state generic)
  139.                                        (lambda args
  140.                                          (if (not (cdr state))
  141.                                          (mop 'register-methods generic))
  142.                                          (let ((method
  143.                                             (or-map
  144.                                              (lambda (mc)
  145.                                                (method-case-applies mc args))
  146.                                              (cdr state))))
  147.                                            (if (not method)
  148.                                            (error 'no-applicable-method args))
  149.                                            (apply (cadr method) args)))))
  150.                                      state generic args))
  151.                                  ((set-state!)
  152.                                   (apply (or (kw-arg-ref mop-options :set-state!)
  153.                                      (lambda (old-state generic new-state)
  154.                                        (set! state new-state)))
  155.                                      state generic args))
  156.                                  
  157.                                  ((state)
  158.                                   (apply (or (kw-arg-ref mop-options :set-state!)
  159.                                      (lambda (state generic) state))
  160.                                      state generic args))
  161.                                  (else (let ((f (kw-arg-ref mop-options
  162.                                             (symbol->keywork protocol))))
  163.                                      (apply (or f default-method)
  164.                                         state generic args))))))))
  165.                      (apply mop 'init mop args))))))
  166.     (list basic-make-generic basic-mop basic-generic?))))
  167.  
  168.   (define basic-make-generic (car generic-things))
  169.   (define basic-generic-mop (cadr generic-things))
  170.   (define basic-generic? (caddr generic-things)))
  171.  
  172.  
  173. (define (basic-meta-object-protocol prot obj . args)
  174.   (let ((mop (basic-generic-mop obj)))
  175.     (apply mop prot obj args)))
  176. (define (basic-add-method! obj sig proc . args)
  177.   (apply basic-meta-object-protocol 'add-method! obj sig proc args))
  178. (define (basic-register-methods obj . args)
  179.   (apply basic-meta-object-protocol 'register-methods obj args))
  180.  
  181. (define (generalize-basic-method op)
  182.   (let ((gen (basic-make-generic)))
  183.     (basic-add-method! gen #t op)
  184.     gen))
  185.  
  186. (define make-generic (generalize-basic-method basic-make-generic))
  187. (define generic-mop (generalize-basic-method basic-generic-mop))
  188. (define generic? (generalize-basic-method basic-generic?))
  189. (define add-method! (generalize-basic-method basic-add-method!))
  190. (is-a basic-generic? generic?)
  191. (provide 'generics)
  192.